perm filename LINELN.F4[RST,LCS] blob
sn#178138 filedate 1975-09-21 generic text, type T, neo UTF8
00100 SUBROUTINE LINELN
00110
00120 DATA ZLINE/150.0/,HX/2./
00130
00200 COMMON/XRN/RN(2000) /SF/KL,RT,KP,STFSZ,NAMX
00300 COMMON RS,JA,CLEF,RA,RQ(16),K,N,J,JJ,KB,NA
00410 COMMON/STF/RSTFAC(-3/4),XLINE
00420 COMMON/POSI/STFF(-3/4),SIG,PQ/PTR/PWDS(250),L,LL,I,RX
00430 DIMENSION IV(78)
00500 EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
00600 1,(R8,RQ(6)),(R9,RQ(7)),(IV,PWDS)
00700 COMMON /PX/SX,PN(2000),Q(10000)
00710 I=L
00720 KK=1
00730 XLINE=ZLINE
00740 ENDLN=Q(IFIX(PN(L))+3)
00750 J=ENDLN/XLINE+.5
00760 TYPE 4,J
00770 4 FORMAT(I4,' LINES - OR TYPE NUM --',$)
00780 ACCEPT 5,RA
00790 5 FORMAT(F)
00792 IF(RA.NE.0)XLINE=ENDLN/RA
00795 RA=0
00800 CLEF=-99
00900 SIG=CLEF
01100 100 KL=1
01300 KP=1
01600 RT=2
01800 J=KK
01900 HGT=HX*3
02000 DO 1 K=KK,I
02100 N=PN(K)
02200 IF(Q(N+1).NE.4)GO TO 1
02300 IF(Q(N).GT.2)GO TO 1
02400 IF(Q(N+3).LT.XLINE)GO TO 1
02500 C FOUND LAST BAR LINE.
02510 RX=0
02600 3 JJ=KP
02700 C PUTS IN STAFF
02800 CALL STAFF(8.,0,STFSZ)
02810 RN(KL-2)=HGT
02820 HGT=HGT-HX
02900 IF(KP.EQ.1.AND.KK.EQ.1)GO TO 33
03000 IF(CLEF.EQ.-99)GO TO 33
03100 C ONLY STAFF FOR FIRST LINE AT TOP.
03200 RX=10*STFSZ
03300 C THE SPACER
03500 CALL STAFF(3.,1.,CLEF)
03600 IF(SIG.EQ.-99)GO TO 33
03700 RX=12*STFSZ
03800 C CLEF+SIG
04000 CALL STAFF(17.,11.0*STFSZ,SIG)
04100
04200 33 R4=RA
04300 R5=Q(N+3)
04400 RS=3
04500 R7=RT
04600 R8=RX
04700 R9=200.
04800 LL=0
04900 L=I-J+1
05000 CALL PTMOVE(Q,PN(J))
05100 RA=R5
05200 KB=KL
05300 DO 30 NA=KK,K
05400 PWDS(KP)=KB
05500 KP=KP+1
05510 JK=PN(NA)
05520 R=Q(JK+1)
05530 IF(R.NE.5)GO TO 35
05540 IF(Q(JK+6).GT.201.)Q(JK+6)=201.
05550 C CATCHES END NF SLUR
05560 GO TO 30
05570 35 IF(R.NE.2)GO TO 36
05580 IF(Q(JK).LT.6.)GO TO 30
05590 RR=Q(IFIX(PN(NA-1))+3)
05600 Q(JK+3)=RR-1.6*STFSZ+(Q(IFIX(PN(NA+1))+3)-RR)/2.
05605 C CENTERS WHOLE REST
05607 GO TO 30
05610 36 IF(R.NE.3)GO TO 34
05619 RR=Q(JK+5)
05628 IF(Q(JK).LT.3)RR=0
05637 IF(RR.LE.3)CLEF=RR
05646 GO TO 30
05655 34 IF(R.NE.17)GO TO 30
05664 SIG=Q(JK+5)
05673 IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
05682 C CLEF # IN P6 WITH KEY SIGS.
05691 30 KB=PN(NA+1)-PN(NA)+KB
05700
05800 DO 31 NA=IFIX(PN(KK)),IFIX(PN(K+1)-1.)
05900 RN(KL)=Q(NA)
06000 31 KL=KL+1
06050 KK=K+1
06100 RS=RT
06200 LL='J'
06300 R4=0
06400 R5=200
06500 NA=L
06600 L=KP-JJ+1
06700 CALL PTMOVE(RN,PWDS(JJ))
06800 L=NA
06900 J=K+1
07000 C SO IT DOESN'T GO THRU ALL DATA
07100 RT=RT-1
07200 XLINE=RA+ZLINE
07300 IF(K.EQ.I)GO TO 2
07310 10 IF(KL.GT.1700.OR.KP.GT.190.OR.RT)GO TO 2
07400 1 IF(K.EQ.I)GO TO 3
07600 2 L=KP
07610 PWDS(KP+1)=KB
07670 J=1
07718 CALL OFILE(1,NAMX)
07766 LL=PWDS(L+1)
07770 2929 WRITE(1),L,LL,
07780 1(PWDS(N),N=1,L+1),(RN(N),N=1,LL-1),J,J,J,J,RSTFAC,STFF,IV,STFF
07785 TYPE 101,NAMX
07787 101 FORMAT(1XA5)
07790 IF(KK.GE.I)CALL EXIT
07800 NAMX=NAMX+2
07810 END FILE(1)
07820 GO TO 100
07910 END
07920
07930 SUBROUTINE STAFF(P1,P3,P5)
08000 COMMON/XRN/RN(2000) /SF/KL,RT,KP,STFSZ,NAMX
08100 COMMON /PTR/PWDS(250),L,LL,I,IX
08200 PWDS(KP)=KL
08210 KP=KP+1
08300 RN(KL)=3.
08400 RN(KL+1)=P1
08500 RN(KL+2)=RT
08600 RN(KL+3)=P3
08700 RN(KL+4)=0
08810 IF(P1.NE.17)GO TO 1
08820 IF(P5.LT.50)GO TO 1
08830 RN(KL)=4.
08835 R=IFIX((P5+50.)/100.)
08840 RN(KL+6)=R
08850 RN(KL+5)=P5-R*100.
08860 KL=KL+7
08870 RETURN
08880 1 RN(KL+5)=P5
08900 KL=KL+6
09000 END